perm filename INDEXR.584[LIB,LSP]1 blob
sn#291923 filedate 1977-07-08 generic text, type T, neo UTF8
;;;###################################################################
;;;
;;; INDEXR
;;;
;;; A programmable system for indexing LISP code
;;;
;;;###################################################################
;;; this file is continually being adjusted- caveat emptor (6/76)
; changes between version 529 (9/7/76), and ????
;
; 1. *TOPLEVEL*'s plist set to nil by INDEXR
; 2. output scheme for WARNINGS
; 3. STUDY-DO uses STUDY-PROG-BODY
; - old form processing rewritten for clarity
; 4. STUDY-LAP written
; 5. STUDY-SETSYNTAX written (!! check against Rich's code !!)
; 6. output functions written for FEXPRS/file and SPECVARS/file
; 7. output functions done over for newio
(declare (newio t)(macros t)(muzzled t)(expr-hash t)(mapex t))
(declare (special functions-called-at-toplevel interesting-lisp-fns defunction *car
tag ;because mapc2 lambda's are compiled as separate fns
output-fns file-spec
tab-length
exp-read ;to get something to look as while compiled
dcl-fns last-read timer file-undefns file-dcls
studyfns interpreted-study-fns file-spec
automatic-printout
indexr-readtbl
user-props
file-defuns early-defprops
exp one-pass freevars sourse-fn printing-base output-fns
default-outfile body))
(DECLARE (SPECIAL PAGESIZE BAR LINEL ALPHABETICAL PRINT-TTY PRINT-FILE
FN-PRINT EXPAND-MACROS DEBUGGING ANTI-LOSSAGE U-WRITE U-FILE
PASS1-PAUSE MAPPING FN FIRST-UNIT UNIQUE PAGENUMBER
PAGE LINECOUNT FILE-GLOBALSET FILE-SPECVARS MAPPING-SPECIAL
FILECALLS LISPFN-FACTS USERVAR-FACTS USERFN-FACTS VERSION#
CDR CAR MAPPING EXPAND-MACROS UNSEEN-GOTAGS TAGS TYPE
FILEFNS PASS COLUMN BAR LINEL PAGESIZE > /.INDEX CHRCT HEAD
LL ALPHABETICAL FUNCTIONS-TO-CHECK ORPHANS U-FILE VERSION# R
U-WRITE DEBUGGING ANTI-LOSSAGE FN-PRINT PAGENUMBER Q
FIRST-UNIT W PRINT-TTY TEMP FILE BOUNDVARS PASS1-PAUSE
MULTIPLE-FILES? FN LINECOUNT UNIQUE PAGE
MULTIPLE-FILES DEFINED-FNS UNDEFNS FILENAMES REALFILES
GLOBAL-SET MAPPING-SPECIAL TOPLEVEL-VARS USERVARS USERFNS
LISPFNS USER-NAME UNSEEN-GOTAGS TAGS VAR-EXPS REP-VAL
INIT-VAL LIST FACT-LIST FACTLIST FNS FILES-SEEN FILENAMES
MARGIN MESSAGE PROTO-LIST FINAL-LIST TEMP L1 L2 PIECES ATOMS
L ARGS FNS-PASSED-THROUGH PRINT-COL DCL EXTRA-FNS FILELIST
FILES FILEFNS FILE READ-SF PASS FIRST? CURRENT-UNIT)
(*EXPR DIGEST-FILESPEC-LIST MARK NOTE-LOCATION PASS1 PASS2
STUDY STUDYFILES SYSTEMFN? WARN MAKE-DCLS MARKUP TRACEBACK
ALPHABETIZE? ALPHABETIZE ASORTPFX AMERGE ADDBOUND ADDL1 ADDP
CHOOSE CHOOSE-A DP FILENAME-OF LIST-IFY MAPC-X MAPC2 NCDR
NTERPRI SAY-M STERILIZE TODAYS-DATE STANDARD-OUTPUT MY-OUTPUT
STANDARD REVIEW-USERFNS REVIEW-USERVARS INDEX-OF-FNS
INDEX-VARS REVIEW-LISPFNS MULTI-FILE-DATA FN-DISTRIBUTION
CENTER-STARTER DESCRIBE DESCRIBE-M INDIND INDPRINT LINE-OF
MAPRINT NEXTPAGE PAGE PRINTFACT PRINTFACT1 PRINTHEADER
SECTION-HEADER TAB NTURPRI TURPRI DEFPROP-PASS
DEFPROP-FUNCTION-PASS DEFUN-PASS FDEF FDEF1 FDEFS2
STRAIGHT-MAP STUDY-APPLY STUDY-ARRAY STUDY-BREAK STUDY-CATCH
STUDY-COND STUDY-DECLARE STUDY-DO STUDY-ERR STUDY-ERRSET
STUDY-EVAL STUDY-EQ STUDY-FUNCALL STUDY-GO STUDY-LAMBDA
STUDY-MACRO STUDY-MAP STUDY-NOT-ATOM-FN STUDY-QUOTE STUDY-PROG
STUDY-SETQ STUDY-SSTATUS STUDY-STATUS STUDY-THROW STUDY-VAR)
(*FEXPR ERT DEFLIST INTEROGATE-YES LIST-NO-NILS SAY)
(*LEXPR MAKE-ATOM index makefile)
(MAPEX T)
(GENPREFIX INDEXR))
;;*page
;;;################ lisp nastyness to allow accessing non-existant list str.
(setq car t cdr t)
;################ enable the - " - macro in interpreter and compiler,
;################ so as to preserve mixed upper and lower pnames.
(declare (eval (read))(eval (read)))
(cond ((not (get 'set2qm 'subr)) ;access it
(fasload /"macro fasl dsk liblsp)))
(SET2QM) ;turn it on
;;*set2qm
;;;#################################################################
;;; macro definitions
;;;#################################################################
(DECLARE (MACROS T) (MAPEX T))
(DEFUN ADDL MACRO (EXP)
(PROG (LIST ITEM)
(SETQ LIST (CADR EXP) ITEM (CADDR EXP))
(COND ((NOT (EQ (CAR LIST) 'QUOTE))
;;explicitly named list
(RPLACA EXP 'ADDL1))
(T (SETQ LIST (CADR LIST))
(RPLACA EXP 'OR)
(RPLACD EXP
(LIST (LIST 'MEMQ ITEM LIST)
(LIST 'SETQ
LIST
(LIST 'CONS ITEM LIST))))))
(RETURN EXP)))
(DEFUN SETQ-LIST MACRO (EXP)
;; merely for clear grinding
(RPLACA EXP 'SETQ))
(DEFUN TOPLEVEL-BIND MACRO (EXP)
;;; set's all the variables in its cdr to nil
;;; at toplevel (of course, you only call it at toplevel !!)
(RPLACA EXP 'SETQ)
(RPLACD EXP
(MAPCAN '(LAMBDA (VAR) (LIST VAR 'NIL))
(CDR EXP))))
;;*page
;;;#################################################################
;;; garbage collection scheme (from liblsp)
;;;#################################################################
(DECLARE (UNSPECIAL SPACE VAR NEW) (SPECIAL ↑W ↑R ↑D))
(DEFUN *GCOV* (SPACE)
(PROGN (ALLOC (LIST SPACE
(MAPCAR (FUNCTION PLUS)
(CADR (MEMBER SPACE (ALLOC T)))
'(1024. 1280. 0.))))
(AND ↑D
((LAMBDA (↑W ↑R)
(PRINT (CONS SPACE
'(SPACE INCREASED 1024. WORDS))))
NIL
NIL))
(LIST SPACE (CADR (MEMBER SPACE (ALLOC T))))))
(SETQ GC-OVERFLOW '*GCOV*)
;;*page
;;;**********************************************************************
;;; ALPHABETIZING ROUTINE
;;;**********************************************************************
(SETQ ALPHABETICAL T)
(DEFUN ALPHABETIZE? (LIST) (COND (ALPHABETICAL (ALPHABETIZE LIST)) (T LIST)))
(DEFUN ALPHABETIZE (LL) (SORT LL 'ALPHALESSP))
;;*PAGE
;;;***************************************************************
;;;
;;; GROVELING UTILITY FUNCTIONS
;;;
;;;*****************************************************************
(DEFUN ADDBOUND (ARGS)
;;; common subroutine below STUDY
(cond ((atom args) ; as in a lexpr
(setq args (list args))))
(MAPC '(LAMBDA (ARG)
(ADDP ARG defunction 'BOUND-IN)
(addp defunction arg 'boundvars))
ARGS))
(DEFUN ADDL1 (LIST ITEM)
;;; goes with the macro ADDL, to handle the general case.
(OR (MEMQ ITEM (EVAL LIST)) (SET LIST (CONS ITEM (EVAL LIST)))))
(DEFUN ADDP (ATOM ITEM TAG)
;;; optimized to do only one search of the plist
((LAMBDA (GAI)
;;"gai" = get atom indicator
(COND ((NULL GAI) (PUTPROP ATOM (LIST ITEM) TAG))
((MEMQ ITEM (CADR GAI)))
(T (RPLACA (CDR GAI) (CONS ITEM (CADR GAI))))))
(GETL ATOM (LIST TAG))))
;;; The more obvious form of the above.
;;; (DEFUN ADDP (ATOM ITEM INDICATOR)
;;; (OR (MEMQ ITEM (GET ATOM INDICATOR))
;;; (PUTPROP ATOM (CONS ITEM (GET ATOM INDICATOR)) INDICATOR)))
(DEFUN CALL-S MACRO (EXP)
;;; will eventually be used for the special hack
;;; to take advantage of know-to-be-compiled studyfns
(RPLACA EXP 'FUNCALL))
(DEFUN CHOOSE (F L)
;;; returns those members of the list "l" which are true
;;; under the predicate "F".
(MAPCAN '(LAMBDA (X) (AND (FUNCALL F X) (LIST X))) L))
(DEFUN CHOOSE-A (FUNCTION ATOMS)
;;; selects as above, and alphabetizes all in one step.
(ALPHABETIZE (MAPCAN
'(LAMBDA (ATOM) (AND (FUNCALL FUNCTION ATOM) (LIST ATOM)))
ATOMS)))
(defun current-x-pos ()
; returns the number of the space (from the left) that the next character
; printed will appear on.
(cond (↑w ;if we're not printing to the screen
(1+ (- linel chrct)))
(t (cdr (cursorpos)))))
(DEFUN ERT FEXPR (MESSAGE)
;;; canned read-eval-print loop for breaks inside functions
(PROG (HEARD ↑W ↑Q)
(APPLY 'SAY MESSAGE)
LOOP (PRINT '#)
(CATCH (AND (ERRSET (SETQ HEARD (READ)))
(COND ((MEMQ HEARD '(T NIL ≠P)) (RETURN HEARD))
(T (ERRSET (PRINT (EVAL HEARD))))))
CNTRL-A)
(GO LOOP)))
(defun ertr (readtable)
;starts a break loop with the given readtable in force
(PROG (HEARD ↑W ↑Q)
LOOP (PRINT '>>)
(AND (ERRSET (SETQ HEARD (READ)))
(COND ((MEMQ HEARD '(T ≠P)) (RETURN HEARD))
(T (ERRSET (PRINT (EVAL HEARD))))))
(GO LOOP)))
(DEFUN DEFLIST FEXPR (GLOP)
;;; data definition function
;;; assigns many values for many atoms on a single tag
;;; (deflist tag
;;; atom1 value1
;;; (atom2 atom3 ...) value2
;;; atomN ...)
;;;
(prog (tag)
(setq tag (car glop))
(mapc2 '(lambda (atom value)
(cond ((not (atom atom))
(mapc '(lambda (atom)
(putprop atom value tag))
atom))
(t (putprop atom value tag))))
(cdr glop))))
(defun d (atom)
(prog (value? plist)
(printc '"[")
(princ atom)
(princ '"]")
(cond ((boundp atom)
(printc '"value= ")
(princ (eval atom))
(setq value? t))
(t (princ '" no value")))
(setq plist (plist atom))
(cond ((null plist)
(cond (value? (printc '"no plist"))
(t (princ '" and no plist")))
(return '*)))
(mapc2 '(lambda (tag value)
(printc tag)
(cond ((memq tag '(expr fexpr procedure will-be arg-restrictions))
(or (memq 'grindef (status features))
(fasload grindef fasl com))
(pprin value 'code))
(t (princ '" ")
(princ value))))
plist)
(return '*)))
(DEFUN FILENAME-OF (4-TUPLE)
;;PRESUMES THAT IT is LOOKING At "FN1 FN2 DEV DIR"
(LIST (CAR 4-TUPLE) (CADR 4-TUPLE)))
(DEFUN GETCALL (ATOM TAG ARG)
;;; if the atom has a property with this tag, then
;;; it is called as a function and the function's
;;; value returned. Otherwise NIL is returned.
(PROG (FUNCTION)
(OR (SETQ FUNCTION (GET ATOM TAG)) (RETURN NIL))
(FUNCALL FUNCTION ARG)
(RETURN T)))
(DEFUN INTEROGATE-YES FEXPR (MESSAGE)
((LAMBDA (↑W) (APPLY 'SAY MESSAGE) (EQ (READ) 'Y)) NIL))
(defun left-mar ()
; returns a number which is the curent CHARPOS, taking into account
; whether we are currently going to a file (↑r = t) or to the tty.
(charpos (cond ((and ↑r outfiles)
(car outfiles))
(t tyo))))
(defun line-length ()
; returns a number which is the curent LINEL, taking into account
; whether we are currently going to a file (↑r = t) or to the tty.
(linel (cond ((and ↑r outfiles)
(car outfiles))
(t tyo))))
(DEFUN LIST-IFY (X)
;;IF IT ISN'T A LIST THEN MAKE IT ONE
(COND ((NULL X) NIL) ((ATOM X) (LIST X)) (X)))
(DEFUN MAKE-ATOM PIECES
(SETQ PIECES (LIST-IFY PIECES))
(IMPLODE (MAPCAN '(LAMBDA (PIECE) (EXPLODEN PIECE)) PIECES)))
(DEFUN MAPC-X (FUNCTION L1 L2)
;;DOES CROSS PRODUCT
(MAPC
'(LAMBDA (E1) (MAPC '(LAMBDA (E2) (FUNCALL FUNCTION E1 E2)) L2))
L1))
(DEFUN LIST-NO-NILS FEXPR (PROTO-LIST)
(PROG (FINAL-LIST TEMP)
(MAPC '(LAMBDA (EXP) (AND (SETQ TEMP (EVAL EXP))
(SETQ FINAL-LIST (CONS TEMP FINAL-LIST))))
PROTO-LIST)
(RETURN (NREVERSE FINAL-LIST))))
(DEFUN MAPC2 (X LL)
(PROG (L)
(OR (SETQ L LL) (RETURN LL))
UP (FUNCALL X (CAR L) (AND (CDR L) (CADR L)))
(AND (SETQ L (CDDR L)) (GO UP))
(RETURN LL)))
(DEFUN NCDR (N L)
(DECLARE (FIXNUM N))
(PROG NIL
UP (AND L
(NOT (AND (ZEROP N) (RETURN L)))
(SETQ L (CDR L))
(SETQ N (SUB1 N))
(GO UP))))
(DEFUN NTERPRI (N) (DO ((I N (- I 1.))) ((= I 0.)) (TERPRI)))
(DEFUN QUERY (MESSAGE EXPLANATION)
(PROG (↑R ↑W ↑Q INPUT)
L1 (PRINTC MESSAGE)
L2 (SETQ INPUT (READ))
(COND ((EQ INPUT '?) (PRINTC EXPLANATION) (TERPRI) (GO L2))
((EQ INPUT '≠) (ERT) (GO L1)))))
(DEFUN PRINTC (X) (TERPRI) (PRINC X))
(defun really-printc (exp)
; for getting messages to the console even though somebody has got
; ↑w on.
(prog (↑w)
(printc exp)))
(DEFUN SAY FEXPR (MESSAGE)
(MAPC '(LAMBDA (WORD) (AND (< CHRCT (LENGTH (EXPLODEC WORD))) (TURPRI))
(PRINC WORD)
(PRINC '/ ))
MESSAGE))
(DEFUN SAY-M (MESSAGE MARGIN)
(TAB MARGIN)
(MAPC '(LAMBDA (WORD) (AND (< CHRCT (LENGTH (EXPLODEC WORD)))
(PROGN (TURPRI) (TAB MARGIN)))
(PRINC WORD)
(PRINC '/ ))
MESSAGE))
(defun separate (predicate list)
; returns two lists: those members of LIST that pass the predicate function
; and those that do not. CAR = winners, CDR = losers
(prog (win lose)
(mapc '(lambda (item)
(cond ((funcall predicate item)
(addl 'win item))
(t (addl 'lose item))))
list)
(return (cons win lose))))
(defun split-by-three (list n1 n2)
; subroutine of the column printer - computes pointers breaking LIST
; into three lists. Returns 2 ptrs cons'd together.
; CAR = the N1th cdr of LIST
; CDR = the (N1 + N2)th cdr
;
(prog (ptr1 rest-of-list)
(setq rest-of-list
(do ((i 0 (1+ i))
(l list (cdr l)))
((= i n1) l)))
(setq ptr1 rest-of-list)
(setq rest-of-list
(do ((i 0 (1+ i))
(l rest-of-list (cdr l)))
((= i n2) l)))
(return (cons ptr1 rest-of-list))))
(DEFUN STERILIZE (ATOMS PROPERTIES)
(MAPC-X (FUNCTION REMPROP) ATOMS PROPERTIES))
(DEFUN TODAYS-DATE NIL
;; returns an atom (interned) whose pname is the current
;;<month>/<day>/<year>
((LAMBDA (BASE *NOPOINT RAW-DATA)
(IMPLODE (APPEND (EXPLODE (CADR RAW-DATA))
'(//)
(EXPLODE (CADDR RAW-DATA))
'(//)
(EXPLODE (CAR RAW-DATA)))))
10.
T
(STATUS DATE)))
(defun top-n (n list)
; returns a list made up of the first N toplevel elements in
; LIST. -copies (sigh...)
((lambda (result)
result) ;for debugging
(top-n1 n list)))
(defun top-n1 (m list)
(cond ((= m 0)
(car list))
(t (cons (car list) (top-n1 (1- m) (cdr list))))))
(DEFUN STARTUP (V DATE NOTES)
; This function is called to initialize and dump an INDEXR core image
; once it is loaded up into a lisp.
(SUSPEND)
(CURSORPOS 'C)
(TERPRI)
(PRINC 'INDEXR/ )
(setq version# v)
(PRINC VERSION#)
(PRINC '/ / / / /c/r/e/a/t/e/d/ )
(PRINC DATE)
(COND (NOTES (TERPRI) (APPLY 'SAY NOTES)))
(SETQ USER-NAME (STATUS UNAME))
(COND ((APPLY 'UPROBE
(LIST 'INDEXR 'INIT 'DSK USER-NAME))
(PRINTC '/i/n/i/t/ /f/i/l/e)
; (APPLY 'LOAD
; (namestring (list (list 'dsk user-name) 'indexr 'init)))
(apply 'mload (list 'indexr 'init 'dsk user-name))))
;"mload" is defined by ddm;.lisp. (init)
;
(cond ((get 'startup 'subr) ;ah! we're in a compiled version of indexr
(pre-scan-study-fns))
(t ;switch in a more optimal version of study (the tight loop)
(putprop 'study
(get 'study-interp 'expr)
'expr)))
'*)
(setq user-name (status uname))
;;; Executed at load-time... Its a convenience for
;;; debugging without calling STARTUP.
(setq version# '"experimental")
;;*page
;;;****************************************************************
;;;
;;; STATISTICS TAKEN BY THE INDEXR
;;;
;;;****************************************************************
(DEFUN FACTS MACRO (EXP)
;;; just a little sugar so grind and the indexr can
;;; chew on them
(RPLACA EXP 'SETQ))
(FACTS USERFN-FACTS
;;; "userfn-facts" is an entity that makes sense to
;;; the printing routines. It consists of a list of lists
;;; where the car of each list is the name of the property
;;; where the given information has been stored on the
;;; property list of some function name. The CADR is the
;;; English message that will be printed preceeding the information.
;;; these sorts of lists are used by the function DESCRIBE.
;;;
'((DEFINED-IN ("defined in the file(s):"))
(dcl-type ("declared return type:"))
(arg-types ("declared argument types"))
(TYPE ("function type:"))
(UNDF-CALL-FROM ("first called from:"))
(EQUIV-TO: ("defined to be equivalant to the function:"))
(ARGUMENTS ("arguments:"))
(CALLED-BY ("called by:"))
(CALLS ("calls the user functions:"))
(UNDEFN-CALLED ("undefined functions called:"))
(BOUNDVARS ("binds the variables:"))
(FREEVARS ("free variables accessed:"))
(FREEVARS-SETQ ("free variables setq'd:"))
(LOWER-SPECIAL ("variables bound here and known to be used free elsewhere:"))))
(FACTS USERVAR-FACTS
'((dcl-type ("declared number type:"))
(BOUND-IN ("bound in the function(s):"))
(SET-ON ("set at toplevel in the file:"))
(SETQ-BOUND ("setg'd while bound in:"))
(SETQ-FREE ("setq'd while free in:"))
(FREE-IN ("accessed while free in:"))))
;################################################################
; "facts" about each indexed file:
;################################################################
;
; These are stored on the generated atom ("filename1<space>filename2") as one
; atom, under the following properties:
;
; -property- -accumulator variable-
; fns-defined FILE-DEFUNS
; - names of functions defined in the file
; fns-declared FILE-DCLS
; - fns declared
; fns-called FILECALLS
; - fns called by code in the file
; specvars FILE-SPECVARS
; - vars accessed by not locally bound
; undefined-fns-called FILE-UNDEFNS
; - (non-lisp) fns called but not defined in the file
; vars-set-at-toplevel FILE-GLOBALSET
; - vars defined by toplevel setq's
; toplevel-calls FILE-SEEN-AT-TOPLEVEL
; - fns called at toplevel as the file is read
; lispfns FILE-LISPFNS
; - lisp fns called (controled by switch - see below)
;*********************************************************
;
; TOPLEVEL bindings
;
; With all the relevant variables bound here at
; toplevel, the world will not be lost if for
; some reason (quit, fatal error) the run is
; aborted allowing the possibility of ingenious
; attempts at picking up where you left off.
;
; These variables are initialized only when the
; function INDEX is entered.
;
;********************************************************
;;;######## collection variables ranging over all files indexed
(SETQ USERFNS NIL
; equals <fns defined> + <fns called> + <fns declared>
USERVARS NIL
;;; all variables mentioned in the code
LISPFNS NIL
;;; any basic lisp function called from the code
TOPLEVEL-VARS NIL
;;; variables found in toplevel setq expressions
FUNCTIONS-CALLED-AT-TOPLEVEL NIL
;;; every atom found in the car of the toplevel functions
;;; in the code (as seen by uread)
MAPPING-SPECIAL NIL
;;; variables that are bound outside mapping functions but
;;; are acessed from within them. - sometimes important
;;; for compilation
FREEVARS NIL
;;; variables ever used free
GLOBAL-SET NIL
;;; found in a toplevel setq expression
REALFILES NIL
;;; a list of the actual file names of the files being indexed
FILENAMES NIL
;;; a list of the first filenames of the above. - file specific
;;; data is attached to these atoms
BOUNDVARS NIL
;;; A recursive variable carried through by functions which can bind variables to
;;; hold all variables known to be bound at any given moment
UNDEFNS NIL
;;; user functions called in the code but not defined there
DEFINED-FNS NIL
;;; names of all the functions defined in the code
IMPLICIT-FUNCALLS NIL
;;; variables detected to be covering function names
EARLY-DEFPROPS NIL
;;; Functions equivalenced to another function by a DEFPROP, where that other function
;;; wasn't yet defined when the defprop was studied.
)
;;;
;;;######### interesting internal control/default variables
;;;
(setq user-name nil
;;; taken from "(status uname)" at the start of a session
)
(SETQ MULTIPLE-FILES? NIL
;;; a switch characterizing each call to indexr
)
(SETQ LINECOUNT 0. PAGE 1. PAGENUMBER 1.)
(SETQ UNIQUE (LIST NIL)
FIRST-UNIT NIL
DEFUNCTION '*TOPLEVEL*
*CAR '*TOPLEVEL*
MAPPING NIL)
;;;################################################################
;;; Toplevel switches
;;;################################################################
(setq interesting-lisp-fns nil
;;; governs whether LISP functions are included in the indexing
;;; (printed out in a separate list) = 'all will keep track
;;; of all fns seen, = (list of fn names) will keep track of
;;; only those fns named.
)
(SETQ ONE-PASS t
;;; turns on the process to do the studying in only one
;;; pass by taking advantage of user declare stmts
)
(SETQ PASS1-PAUSE NIL
;;CAUSES AN ERT ( "READ-EVAL-PRINT" ) LOOP AT THE END OF PASS1
)
(setq automatic-printout nil
;;; Controled by parameters to the call to index. If non-nil, then
;;; a file of the statistics is made immediately after the files
;;; are analysed - otherwise INDEXR returns directly or obeys other
;;; options taken from OPTLIST.
)
(SETQ U-FILE NIL
;;over-rides the default conventions by breaking to have the user do the
;;commands by hand
U-WRITE NIL
;; the same idea
)
(SETQ ANTI-LOSSAGE T
;;PUTS ON OR leaves OFF AN ERRSET ARROUND THE EXAMINATION OF EACH S-EXP
;;READ IN
)
(SETQ EXPAND-MACROS T
;;controls whether macros are indexed open or closed (t = open)
)
(SETQ FN-PRINT T
;;PRINTS THE CADR OF EVERY S-EXP READ IN - GOOD FOR TELLING WHERE YOU ARE
;;AND HOW FAST THINGS ARE PROGRESSING
)
(SETQ PRINT-FILE T
PRINT-TTY NIL
;;SETS THE ↑R AND ↑W SWITCHES DURING STANDARD-OUTPUT and some other
;;places
)
;;;#################################################################
;;;
;;; Main functions of the system
;;;
;;;#################################################################
(DEFUN INDEX args
(prog (raw-filelist print-option options TEMP PAGENUMBER BOUNDVARS FILELIST)
; decode the lexpr's arguments
(setq raw-filelist (arg 1)) ;obligatory
(cond ((> (arg nil) 1)
(setq print-option (arg 2))
(cond ((> (arg nil) 2)
(setq options (arg 3)))))
(t ;only filespecs given
(setq print-option t)))
;
; initializations of globally bound data collection variables
(SETQ LISPFNS NIL
USERFNS NIL
dcl-fns nil
USERVARS NIL
TOPLEVEL-VARS NIL
MAPPING-SPECIAL NIL
GLOBAL-SET NIL
REALFILES NIL
FILENAMES NIL
UNDEFNS NIL
DEFINED-FNS NIL )
(setplist '*toplevel* nil)
;
; initialization of more mundane variables
; watching internal str. of user's files and such.
;; default indexr readtable
((lambda (readtable)
(setsyntax 12. 'macro 'nextpage)
(setq indexr-readtbl readtable))
(array nil readtable t))
(SETQ LINECOUNT 0. )
(SETQ FILELIST (DIGEST-FILESPEC-LIST RAW-FILELIST))
; see below for filespec criteria
(COND ((GREATERP (LENGTH FILELIST) 1.)
(SETQ MULTIPLE-FILES? T)))
; "multiple-files?" is globally bound
(decode-options options)
(cond (one-pass (studyfiles filelist 'one-pass)
(one-pass-cleanup))
(t (STUDYFILES FILELIST 'PASS1)
(COND (PASS1-PAUSE
(TERPRI)
(ERT PASS1 COMPLETED)))
(STUDYFILES FILELIST 'PASS2)))
(TERPRI)
(cond ((eq print-option t) (makefile))
(print-option (makefile (symeval print-option)))
(t (printc '"analysis completed")))
(RETURN '*)))
(DEFUN DIGEST-FILESPEC-LIST (RAW-FILELIST)
;;; Possible variations on the file-list in the call to INDEX
;;;
;;; for single files just give the normal file description
;;; (index '(indexr > dsk ddm) t)
;;; or simply '(indexr >)
;;; the default directory is taken from (status uname).
;;;
;;; for multiple files, give a list of the files,
;;; (index '((indexr >)(indexl >)(indexc >) ...) t)
;;; or
;;; (index shrdlu-files t)
;;; where the value of the atom is a list as above
;;;
(COND ((ATOM (CAR RAW-FILELIST)) (LIST RAW-FILELIST)) (T RAW-FILELIST)))
(defun decode-options (optlist)
; The optlist may be NIL - take all default options,
; or it is a list of special atoms, or sublists whose
; CAR's are special atoms.
;
(prog (key)
(or optlist (return t))
(mapc '(lambda (option)
(cond ((atom option)
(cond ((eq option 'two-pass)
(setq one-pass nil))
(t (printc option)
(princ '| unknown option - ignored|))))
(t ;options in lists
(setq key (car option))
(cond ((eq key 'readtable)
((lambda (readtable)
(setsyntax 12. 'macro 'nextpage)
(setq indexr-readtbl readtable))
; enables page counting
(eval (cadr option))))
(t (printc key)
(princ '| unknown option key|))))))
optlist)))
;;*page
(setq timer nil) ;for timing and printing runtime/exp
(DEFUN STUDYFILES (FILES PASS)
; this is the function that examines each file (loops through multiple
; files in the order given). It also manages the collection variables
; associated with individual files.
;
(prog (↑w ↑q exp-read last-read page readtable current-unit first? unique)
; one-shot initializations
(setq readtable indexr-readtbl
↑q t
unique (gensym)
first? t) ; T = reading first of the files
(or print-tty (setq ↑w t))
(terpri) (print '>>>>) (princ pass)
;
; now read all the expressions in all the files
;
(do ((file-spec (car files)(car files))
; the specifications for each file (in turn) as given to INDEX
(filecalls) (file-defuns) (file-specvars) (file-lispfns) (file-undefns)
(file-dcls) (file-globalset) (file-seen-at-toplevel) (file)
;per-file collection variables
(page 1 1) ;records file pages (↑L 's)
)
((prog2 nil (null files) (setq files (cdr files))))
(prog () ;to enable GO tags for user recovery
; first hack the filespecs, and open the file.
; The variable "current-unit" is maintained to help the defaults on
; the filespecs against those occasions when someone inadventantly
; changes the (crunit) between the examination of files
top-of-cycle
(cond ((= (length file-spec) 1) ;just the name - no version number
(setq file-spec (append (list (car file-spec) '>)
(or current-unit
(list 'dsk user-name)))))
((= (length file-spec) 2.)
(setq file-spec (append file-spec
(or current-unit
(list 'dsk user-name)))))
((= (length file-spec) 4.)
(setq current-unit (cddr file-spec)))
(t (printc '"studyfiles: ill-formed file-specification = ")
(prin1 file-spec)
(printc '"setq the variable FILE-SPEC to the correct value and continue by typing /"t /" ")
(ert)
(go top-of-cycle)))
; now open the file
(setq ↑q t)
(cond ((errset (apply 'uread file-spec))
(printc '"reading ")
(princ (status uread)))
(t (printc '"opening your file caused an error losing file= ")
(prin1 file-spec)
(printc '"setq the variable FILE-SPEC to what you really meant and continue by typing /"t /" ")
(ert)
(go top-of-cycle)))
(setq file (car file-spec))
(cond ((or (eq pass 'pass1)
(eq pass 'one-pass))
(setq realfiles (cons (status uread) realfiles)
filenames (cons file filenames))
(putprop file (status uread) 'file-name)))
; now read and study everything in it
(setq pagenumber 1.) ; ?????
read-loop
(cond ((eq unique (setq exp-read (read unique))))
; eof condition - drop out of read-loop
(t (and (atom exp-read)(go read-loop))
; toplevel atoms are ignored
(and fn-print
(printc (cadr exp-read)))
(cond (anti-lossage
(errset (funcall pass exp-read)))
(t (funcall pass exp-read)))
(setq last-read exp-read)
(addl 'file-seen-at-toplevel (car exp-read))
(go read-loop)))
; now that the file has been read through and studied, we transfer
; the statistics collected about the file from variables to properties
; on the file name
; In "one-pass" operation, a reconciliation procedure is run first.
(cond ((eq pass 'one-pass) (reconcile-file)))
(cond ((or (eq pass 'pass1) (eq pass 'one-pass))
(putprop file file-dcls 'fns-declared)
(putprop file file-defuns 'fns-defined)
(setq defined-fns (append defined-fns file-defuns))
; updating the index-wide collection
))
(cond ((or (eq pass 'one-pass) (eq pass 'pass2))
(putprop file file-seen-at-toplevel 'toplevel-calls)
(putprop file filecalls 'fns-called)
(putprop file file-undefns 'undefined-fns-called)
(putprop file file-lispfns 'lispfns)
(putprop file file-globalset 'vars-set-at-toplevel)
(putprop file file-specvars 'specvars)
((lambda (fns)
(putprop file fns 'calls-to-exterior))
(choose (function (lambda (fn)
(not (memq fn file-defuns))))
filecalls)) ))
))))
;;*page
;################################################################
; hackery for faster compiled code
;################################################################
(setq studyfns nil)
; this collection variable will hold all the "study functions" that get
; defined as the system in put together. This way they can be
; scanned before starting and we can check for subrs vs. exprs.
(defun pre-scan-study-fns nil
; does the aforsaid scan, and sets the global variable INTERPRETED-STUDY-FNS
; to the value of any expr-type studyfns it finds (probably written
; by the user).
(cond ((not (get 'pre-scan-study-fns 'subr))
; if this loading of INDEXR is not compiled, then all studyfns are
; interpreted (and the system will run slowly !!)
(mapc '(lambda (studyfn)
(mapc '(lambda (fn)
(cond ((atom fn) (addl 'interpreted-study-fns fn))
(t (mapc '(lambda (f)
(addl 'interpreted-study-fns f))
fn))))
(get studyfn 'used-by)))
studyfns))
(t (mapc '(lambda (studyfn)
(prog (subrptr lisp!userfns)
(setq subrptr (get studyfn 'subr)
lisp!userfns (get studyfn 'used-by))
(cond ((null subrptr)
(mapc '(lambda (fn) ;lisp or user functions
(addl 'interpreted-study-fns fn))
lisp!userfns)
(return nil))
(t (mapc '(lambda (fn)
(putprop fn subrptr 'one-pass-subr))
lisp!userfns)))))
studyfns))))
(setq interpreted-study-fns nil)
; Fns to use inplace of the old DEFLIST for associating lisp/user functions with
; those indexing functions that will study them.
(defun study-one-pass fexpr (pairs)
(process-study-fns pairs 'one-pass))
(defun study-pass1 fexpr (pairs)
(process-study-fns pairs 'pass1))
(defun study-one-pass!pass2 fexpr (pairs)
(process-study-fns pairs (cons 'one-pass 'pass2)))
(defun process-study-fns (pairs tag)
; if a studyfn has been compiled, then it will have a subr property. That subr
; pointer must eventually be associated directly with a property of those lisp/user
; functions that want to use it to get studied with. (phew!) This can't be done
; at the time the file is read in, because the associateing list might be read
; in at any time with/respect/to the studyfns themselves (not to mention user
; init files). So, at readin time, this function makes a link between each
; studyfn and those lisp/user fns that use it, and makes a list of all studyfns.
; That data is used at the start of a session to put the pointers in the right
; places.
(mapc2 '(lambda (lispfn studyfn)
(addl 'studyfns studyfn)
(addp studyfn lispfn 'used-by))
pairs)
(cond ((atom tag)
(apply 'deflist (cons tag pairs))) ;for interpreted use
(t (apply 'deflist (cons (car tag) pairs))
(apply 'deflist (cons (cdr tag) pairs)))))
;;*page
(DEFUN PASS1 (PASS1-ARG)
;; PASS1 IS ONLY INTERESTED IN DEFINITIONS. IT WORKS BY loOKING FOR A
;;FUNCTION ON THE PROPERTY LIST OF THE CAR OF THE EXPRESSION. ONLY
;;THINGS LIKE DEFPROP DEFUN ETC. WILL HAVE THINGS, SO EVERYTHING ELSE
;;IS IGNORED.
((lambda (special-fn)
(and special-fn
(funcall special-fn pass1-arg)))
(get (car pass1-arg) 'pass1)))
(DEFUN PASS2 (PASS2-ARG)
((lambda (special-fn)
(and special-fn
(funcall special-fn pass2-arg)))
(get (car pass2-arg) 'pass2)))
(defun one-pass (one-pass-arg)
; does the work of both passes in one sweep of the files by relying on
; DECLARE's to point out the FEXPRS. -Optomized to look for subrs.
((lambda (*car)
(cond (((lambda (special-subr)
(cond (special-subr (subrcall nil special-subr one-pass-arg))
(t nil)))
(get *car 'one-pass-subr)))
(((lambda (special-fn)
(cond (special-fn (funcall special-fn one-pass-arg))
(t nil)))
(get *car 'one-pass)))
(t (study one-pass-arg))))
(car one-pass-arg)))
(DEFUN STUDY (EXP)
; This is the recursive function that is the workhorse of indexr.
; It uses the CAR of the expression to dispatch to a particular
; pre-defined study function, or a general purpose function.
;
; This version has been optimised for a compiled environment. It runs
; rather slowly if there are many interpreted study-fns mixed in. When the
; system is loaded up fully interpretively, a more optimal version (following)
; replaces this one.
;
((lambda (*car) ;the element being dispatched on !!
(cond ((atom exp) (study-var exp))
(t (cond ((not (atom *car)) (study-not-atom-fn exp))
; study-fns owned by INDEXR or user compiled
(((lambda (special-subr)
(cond (special-subr
(subrcall nil special-subr exp)
(mark *car))
(t nil)))
(get *car 'one-pass-subr)))
; interpreted study-fns
(((lambda (special-fn)
(cond (special-fn
(funcall special-fn exp)
(mark *car))
(t nil)))
(cond (interpreted-study-fns
; at least some of the study fns are not compiled
((lambda (fn)
(cond (fn (get fn pass))
(t nil)))
(car (memq *car interpreted-study-fns))))
(t nil))))
; random exprs (or lexprs - which also eval their args)
((or (getl *car '(subr lsubr))
(memq (car (get *car 'type)) '(expr lexpr))
(memq (get *car 'declared-type) '(expr lexpr)))
(mark *car)
(mapc 'study (cdr exp)))
; fexprs
((or (getl *car '(fsubr autoload)) ;conservative assumption
(eq (car (get *car 'type)) 'fexpr)
(eq (get *car 'declared-type) 'fexpr))
(mark *car)) ;fexprs are not further examined
; macros
((or (eq (car (get *car 'type)) 'macro)
; below lets macros lying around in the core image get into
; the action (requested by Henry Leiberman)
(get *car 'macro))
(study-macro exp))
(t ;if nothing is known about the name, then it is assumed
;to be an EXPR type function - and any irregularities are
;noticed by the function MARK and RECOJCILE.
(mark *car)
(mapc 'study (cdr exp)))
) )))
(car exp)))
(DEFUN STUDY-interp (EXP)
; A carbon copy of STUDY except in its treatment of study-fns. Does a
; straight funcall in place of the subr-ptr hack.
;
((lambda (*car)
(prog (study-fn)
(cond ((atom exp) (study-var exp))
(t (cond ((not (atom *car)) (study-not-atom-fn exp))
((setq study-fn (cadr (getl *car '(one-pass pass2))))
(funcall study-fn exp))
; random exprs (or lexprs - which also eval their args)
((or (getl *car '(subr lsubr))
(memq (car (get *car 'type)) '(expr lexpr))
(memq (get *car 'declared-type) '(expr lexpr)))
(mark *car)
(mapc 'study (cdr exp)))
; fexprs
((or (getl *car '(fsubr autoload)) ;conservative assumption
(eq (car (get *car 'type)) 'fexpr)
(eq (get *car 'declared-type) 'fexpr))
(mark *car)) ;fexprs are not further examined
; macros
((or (eq (car (get *car 'type)) 'macro)
(get *car 'macro))
(study-macro exp))
(t ;if nothing is known about the name, then it is assumed
;to be an EXPR type function - and any irregularities are
;noticed by the function MARK and RECONCILE.
(mark *car)
(mapc 'study (cdr exp)))
) ))))
(car exp)))
;;*page
(DEFUN MARK (*car)
; This routine is run for every function call seen.
; It notes the basic "calls called-by" data and contemplates the
; defined-ness of the calling function.
;
(cond ((eq pass 'one-pass) (mark1 *car))
(t (mark0 *car))))
(defun mark0 (*car)
; *car has the name of the function doing the calling
; This version of mark only will be called during the second pass
; of a two pass indexr. Any defined fn will have a DEFINED-IN property,
; anything else is either a system function, or undefined and is noted
; as such.
(prog ()
(COND ((get *car 'defined-in))
; garden variety - calling a user defined function.
((SYSP *car)
;;; the default case is to not record anything
;;; about LISP fns. This option is controled by the switch
;;; INTERESTING-LISP-FNS, which is initially NIL.
(COND ((EQ INTERESTING-LISP-FNS 'ALL)
(ADDL 'LISPFNS *car)
(ADDP *car DEFUNCTION 'CALLED-BY)
(ADDP DEFUNCTION *car 'LISP-CALLS))
((MEMQ *car INTERESTING-LISP-FNS)
(ADDP *car DEFUNCTION 'CALLED-BY)
(ADDP DEFUNCTION *car 'LISP-CALLS)))
(RETURN T))
((OR (MEMQ *car BOUNDVARS) (MEMQ *car TOPLEVEL-VARS))
(WARN 'IMPLICIT-FUNCALL)
(RETURN T))
(T (ADDP DEFUNCTION *car 'UNDEFN-CALLED)
(ADDL 'UNDEFNS *car)
(ADDL 'FILE-UNDEFNS *car)
(ADDP *car '*UNDEFINED* 'TYPE)
(ADDP *car (NOTE-LOCATION) 'UNDF-CALL-FROM)
(ADDL 'USERFNS *car)))
; even for the undef-calls, include then in the general statistics
(ADDP *car DEFUNCTION 'CALLED-BY)
; DEFUNCTION is the name of the fn. definition currently being studied
(ADDP DEFUNCTION *car 'CALLS)
(addl 'userfns *car)
(ADDL 'FILECALLS *car)
(return t)))
(defun mark1 (*car)
; The mark function for "one-pass"operation. Undefined functions are
; not "seen" until a comparasin is make at the end of the run.
; N.B. this routine will lose if the code uses a redefined lisp fn
; before it defines it !!!
(prog nil
(cond ((get *car 'defined-in))
((get *car 'declared-type))
((SYSP *car)
(COND ((EQ INTERESTING-LISP-FNS 'ALL)
(ADDL 'LISPFNS *car)
(ADDP *car DEFUNCTION 'CALLED-BY)
(ADDP DEFUNCTION *car 'LISP-CALLS))
((MEMQ *car INTERESTING-LISP-FNS)
(ADDP *car DEFUNCTION 'CALLED-BY)
(ADDP DEFUNCTION *car 'LISP-CALLS)))
(RETURN T)))
;undefined functions slip through.
(addp *car defunction 'called-by)
(addp defunction *car 'calls)
(addl 'userfns *car)
(addl 'filecalls *car)
(return t)))
(defun reconcile-file ()
; same as ONE-PASS-CLEANUP, but on a per file basis
(setq file-undefns
(choose (function (lambda (fn)
(not (eq (caar (get fn 'defined-in))
file))))
filecalls)))
(defun one-pass-cleanup ()
; makes observations that couldn't have been made on the fly.
; This should come to have a hook for similar calculations required
; by the user.
; 1. calculates actual undefined fns in the indexed code.
; 2. removes function which are only declared, but not defined from the list
; of userfns.
;
(prog (file-undefns filtered-userfns)
(setq file-undefns (mapcan '(lambda (file) (get file 'undefined-fns-called))
filenames))
(setq undefns (choose (function (lambda (fn) (not (get fn 'defined-in))))
file-undefns))
;
(mapc '(lambda (fn)
(cond ((and (get fn 'declared-type)
(not (get fn 'type))))
(t (setq filtered-userfns (cons fn filtered-userfns)))))
userfns)
(setq userfns filtered-userfns)
;
;!!!!!!!!! hack, hack, hack
; some wierd lists - probably parts of property lists of the arguments to
; LEXPR's ??? - are getting into USERVARS.... this removes them without
; getting to the root of the matter.
(prog (new-list)
(mapc '(lambda (atom?)
(cond ((atom atom?) (addl 'new-list atom?))))
uservars)
(setq uservars new-list))
))
(DEFUN NOTE-LOCATION NIL
;;returns a list which is intended to be printed directly
;;; such as: (INDEX in (INDEXR 305) pg. 10)
(LIST DEFUNCTION
'"in"
(FILENAME-OF (STATUS UREAD))
'"pg."
PAGE))
(defun location nil
; returns a list to be directly printed later.
; e.g. (indexr 400 pg. 10)
(append (filename-of (status uread))
(list '" pg." page)))
(defun location-atom nil
; returns an atom to get manipulated (its pname spliced onto)
(implode (append (exploden (filename-of (status uread)))
(exploden '" pg. ")
(exploden page))))
;;*PAGE
;################################################################
; Warnings
;
; - "warnings" are just a way to get arbitrary text out to the
; documentation file... for those phenomena that are not so
; common, or cannonically described, that a line of English
; would be best.
;
; /////--- not hooked to output due to questions of how to
; arrange it -10/25/76 ------///////
;
; Most warnings just consist of a phrase to be printed out with
; the offending function definition or call. As such a simple
; table lookup could be used. However, on the principle of supplying
; enough rope for getting hung with, i've made them all functions
; presuming that the message might well want to be constructed at
; execution time, and that the point of attachment (file, defined
; function, called function ...) could not be standardized.
;
(DEFUN WARN (TYPE-OF-WARNING)
(FUNCALL TYPE-OF-WARNING))
;need good hack for when DEFUNCTION = *TOPLEVEL*
(defun calls-macro-before-its-defined ()
(addp defunction
(list '"Call to the macro " *car '"before it is defined")
'warnings))
(defun dcl-def-type-mismatch nil
(addp defunction
'"Warning !!! - your declaration disagrees with the definition !!
this may have caused a bad indexing"
'warnings))
(DEFUN FN-WITH-NON-ATOMIC-ARG NIL
(ADDP DEFUNCTION
'"warning: this function has a non-atomic argument"
'WARNINGS))
(defun fn-type-miss-studied nil
(cond (args ;there is something to have been miss-studied
(mapc '(lambda (fn)
(addp fn
(list '"the arguments in the call to" defunction
'"may have been miss-studied" '"due to bad declaration")
'warnings))
(get defunction 'called-by)))))
(DEFUN IMPLICIT-FUNCALL NIL
(ADDP DEFUNCTION
(LIST '"warning: the following expression " (CAR EXP)
'"is used as a function")
'WARNINGS))
(defun macro-lost nil
(addp defunction
(list '"an error occured trying to expand the macro " *car)
'warnings))
(defun missing-go-tag nil
(addp defunction
(list '"these names were gone-to but no prog-tags were found: " unseen-gotags)
'warnings))
(DEFUN PROG-NON-ATOMIC-VAR NIL
(ADDP DEFUNCTION
'"warning: non-atomic expression seen in the variable list of a prog"
'WARNINGS))
(DEFUN REDEFINE-SYSFN NIL
(ADDP '*toplevel*
(LIST '"warning: the function: " DEFUNCTION
'" was a system function before you redefined it")
'WARNINGS))
(defun setq-non-atomic-exp nil
(addp defunction
'"attempting to SETQ a non-atomic variable"
'warnings))
(defun strange-function-definition-without-lambda nil
(addp defunction
(list '"the DEFPROP at " (location-atom) '"doesn't have a LAMBDA")
'warnings))
(defun unsetsyntax nil t)
;################################################################
; Study-functions for function definitions #
;################################################################
(study-pass1
DEFPROP DEFPROP-PASS )
(study-one-pass
defprop defprop-pass)
(DEFUN DEFPROP-PASS (EXP)
((lambda (tag)
(cond ((memq tag '(expr fexpr macro))
(defprop-function-pass exp))
(t ;study it like you study PUTPROP
((lambda (defunction)
(addp defunction tag 'puts-prop)
(addl 'user-props tag)
(addp tag defunction 'put-by))
(cond ((eq defunction '*toplevel*)
(location-atom))
(t defunction)) )) ))
(cadddr exp)))
(DEFUN DEFPROP-FUNCTION-PASS (EXP)
; When an actual lambda-expression has been given as the definition, it is passed
; off to FDEF - made to look like a defun.
; When it is actually an equivalence, it is handled here.
(prog (defunction body type)
(setq defunction (cadr exp)
body (caddr exp)
type (cadddr exp))
(cond ((not (atom body))
(cond ((eq (car body) 'lambda)
;"(fdef <name><type><args><body>)"
(fdef defunction type (cadr body)(cddr body)) )
(t (warn 'strange-function-definition-without-lambda)) ))
(t ;the equivalence case. We need to record its TYPE so that STUDY will
;work. We can record that it was defined at this location. If the
;funcition it is equivalence to is defined by now, we can check the
;types and note that this function is defined. Otherwise, we have to
;put a trap on said function, and if it never becomes defined, the
;ONE-PASS-CLEANUP routine will add a special fact to it.
(addl 'userfns defunction)
(addl 'defined-fns defunction)
(addl 'file-defuns defunction)
(addp defunction type 'type)
(addp defunction body 'equiv-to)
(addp defunction (location-atom) 'defined-in)
(cond ((get body 'args)) ;i.e. does that function really exist?
(t ;no, we have to put it on a list to be checked at cleanup
(addl 'early-defprops defunction))) ))
))
(study-pass1 defun defun-pass)
(study-one-pass defun defun-pass)
(DEFUN DEFUN-PASS (EXP)
; sets up "defun" function definitions for both passes
(COND ((MEMQ (CADDR EXP) '(EXPR FEXPR MACRO))
; as is "(defun foo fexpr (args) body)"
(FDEF (fname (CADR EXP)) (CADDR EXP) (CADDDR EXP) (CDDDDR EXP)))
((MEMQ (CADR EXP) '(EXPR FEXPR MACRO))
; as in "(defun fexpr foo (args) body)"
(FDEF (fname (CADDR EXP)) (CADR EXP) (CADDDR EXP) (CDDDDR EXP)))
(T ; as in "(defun foo (args) body)"
(FDEF (fname (CADR EXP)) 'EXPR (CADDR EXP) (CDDDR EXP)))))
(DEFUN FDEF (DEFUNCTION TYPE ARGS BODY)
(COND ((EQ PASS 'PASS1) (FDEF1 DEFUNCTION TYPE ARGS))
(ONE-PASS (FDEF-ONE-PASS DEFUNCTION TYPE ARgs BODY))
(T (FDEFS2 ARGS BODY))))
(defun fname (name?)
; a subroutine for processing the new "fn on any property" defun-syntax
(cond ((atom name?) name?)
((eq (cadr name?) 'expr) ;for when only the complr tag is changed.
(car name?))
(t ; the new format will direct the interpreter or the compiler to
; put the lambda (subr) it creates on any arbitrary property.
; (defun (foo p1 p2) (args) body)
; The interpreter will put the lambda-exp under the tag P1 on the
; atom FOO. The compiler will put its subr-exp under P2.
; For indexing purposes, the "name" of such a function - the
; atom that stands for it in the indexing, will consist of the
; function's pname concatenated with "$" and then with its P1 tag.
; Special indexing fns will be required to catch calls to
; these functions.
(implode (append (exploden (car name?))
(exploden '"$")
(exploden (cadr name?)))) )))
(DEFUN FDEF1 (DEFUNCTION TYPE ARGS)
; this processes function definitions during the first pass.
; it records their:
; place of definition - DEFINED-IN
; function type - TYPE
; and arguments - ARGUMENTS
;
(PROG ()
; detect LEXPRs
(cond ((and (atom args) (not (eq args nil)))
; differentiate between lexpr's and exprs of no arguments
(setq args (list args)) ;output convention
(setq type 'lexpr)))
;
; check for redefining system fns
((lambda (sys-status)
(and sys-status
(not (and (= (length sys-status) 1)
(eq (car sys-status) 'value))) ;just a system atom
(warn 'redefine-sysfn)))
(status system defunction))
;
; check for multiply defined functions
(cond ((get defunction 'defined-in)
(addl 'file-undefns defunction)))
; multiple definitions become reflected by multiple elements in
; their DEFINED-BY and TYPE properties (parallel entries) - the
; CAR of the property always gives the most recent version.
; n.b. Study of the body of such multiple definitions is not
; kept separate, and will come out as a hodgepodge.
;
; compile the usual data
;
(addl 'userfns defunction)
(addl 'defined-fns defunction)
(addl 'file-defuns defunction)
(putprop defunction (cons (location) (get defunction 'defined-in)) 'defined-in)
(putprop defunction (cons type (get defunction 'type)) 'type)
(putprop defunction (or args '(*no-arguments*)) 'arguments)
))
(DEFUN FDEFS2 (ARGS BODY)
(PROG NIL
(AND (NULL BODY) (RETURN T))
(and (equal (get defunction 'type) '(lexpr))
(setq args (list args)))
(ADDBOUND ARGS)
(MAPC '(LAMBDA (V)
(OR (ATOM V) (WARN 'FN-WITH-NON-ATOMIC-ARG))
(ADDL 'USERVARS V))
ARGS)
(COND ((EQ TYPE 'MACRO)
(PUTPROP DEFUNCTION
(CONS 'LAMBDA (CONS ARGS BODY))
'MACRO)))
((LAMBDA (BOUNDVARS) (MAPC 'STUDY BODY))
(APPEND (LIST-IFY ARGS) BOUNDVARS))))
(defun fdef-one-pass (defunction type args body)
; Does everything that FDEF1 and FDEF2 did, plus worries about the declarations.
; It is largely a concatenation of the two !!
; To the function name it adds the properties:
; DEFINED-IN, TYPE, ARGUMENTS
; adds the name to the collection variables - FILE-DEFUNS
; and arranges to get the BODY further studied.
;
(PROG ()
; detect LEXPRs
(cond ((and (atom args) (not (eq args nil)))
(setq args (list args)) ;output convention
(setq type 'lexpr)))
;
; check for redefining system fns
((lambda (sys-status)
(and sys-status
(not (and (= (length sys-status) 1)
(eq (car sys-status) 'value))) ;just a system atom
(warn 'redefine-sysfn)))
(status system defunction))
;
; check for multiply defined functions
(cond ((get defunction 'defined-in)
(addl 'file-undefns defunction)))
;
; check for deviation from declared type (a henious sin!)
((lambda (dcl-type)
(cond ((and dcl-type (not (eq dcl-type type)))
(warn 'dcl-def-type-mismatch)
(cond ((get defunction 'called-by)
(warn 'fn-type-miss-studied))))))
(get defunction 'declared-type))
;
; compile the usual data
;
(addl 'userfns defunction)
(addl 'defined-fns defunction)
(addl 'file-defuns defunction)
(putprop defunction (cons (location) (get defunction 'defined-by)) 'defined-in)
(putprop defunction (or args '(*no-arguments*)) 'arguments)
;pass two on next page
;
; now pass2 stuff
;
(cond ((NULL BODY)
(warn 'defun-wo-body)
(RETURN T)))
;
; set up the variables
(and (equal (get defunction 'type) '(lexpr))
(setq args (list args))) ; preping for ADDBOUND
(ADDBOUND ARGS)
(MAPC '(LAMBDA (V)
(OR (ATOM V) (WARN 'FN-WITH-NON-ATOMIC-ARG))
(ADDL 'USERVARS V))
ARGS)
;
; keep a copy of macros - to open them up in later calls
(COND ((EQ TYPE 'MACRO)
(PUTPROP DEFUNCTION
(CONS 'LAMBDA (CONS ARGS BODY))
'MACRO)))
;
; DO IT !! - get the body studied
((LAMBDA (BOUNDVARS) (MAPC 'STUDY BODY))
(APPEND (LIST-IFY ARGS) BOUNDVARS))
(putprop defunction (cons type (get defunction 'type)) 'type)
; to try an have the type property on the front of the plist
))
;################################################################
; Study functions for standard MACLISP functions #
;################################################################
(study-one-pass!pass2
;gives each function name a both a ONE-PASS and a PASS2 property
;at the same time
AND STRAIGHT-MAP
APPLY STUDY-APPLY
ARRAY STUDY-ARRAY
BREAK STUDY-BREAK
CATCH STUDY-CATCH
COMMENT NO-OP
COND STUDY-COND
DECLARE STUDY-DECLARE
DEFUN DEFUN-PASS
DEFPROP DEFPROP-PASS
DO STUDY-DO
ERR STUDY-ERR
ERRSET STUDY-ERRSET
EQ STUDY-EQ
EVAL STUDY-EVAL
GO STUDY-GO
FUNCALL STUDY-FUNCALL
FUNCTION
STUDY-QUOTE
LAMBDA STUDY-LAMBDA
LAP STUDY-LAP
LIST STRAIGHT-MAP
MACRO STUDY-MACRO
(MAP MAPC MAPCAR MAPLIST MAPCAN MAPCON)
STUDY-MAP
MEMQ STUDY-EQ
OR STRAIGHT-MAP
PROG STUDY-PROG
PROGN STRAIGHT-MAP
QUOTE STUDY-QUOTE
SETQ STUDY-SETQ
SETSYNTAX STUDY-SETSYNTAX
SSTATUS STUDY-SSTATUS
STATUS STUDY-STATUS
THROW STUDY-THROW)
;################ general purpose
(DEFUN NO-OP (EXP) T)
(DEFUN STRAIGHT-MAP (EXP) (MAPC 'STUDY (CDR EXP)))
;################ MACLISP functions (alphabetically)
(DEFUN STUDY-APPLY (EXP)
(COND ((OR (ATOM (CADR EXP))
(NOT (MEMQ (CAADR EXP) '(FUNCTION QUOTE)))))
; evaluated functional in use - perhaps a warning ???
((ATOM (CADADR EXP)) (MARK (CADADR EXP)))
((EQ (CAR (CADADR EXP)) 'LAMBDA)
(STUDY-LAMBDA (CADADR EXP))))
(STUDY (CADDR EXP)))
(defun study-array (exp) t)
(DEFUN STUDY-BREAK (EXP)
;;; may not match current format !!!!!!
(AND (CDR EXP)
(CDDR EXP)
(PROGN (STUDY (CADDR EXP)) (AND (CDDDR EXP) (STUDY (CADDDR EXP))))))
(DEFUN STUDY-CATCH (EXP) (STUDY (CADR EXP)))
(DEFUN STUDY-COND (EXP)
(MAPC '(LAMBDA (CLAUSE) (MAPC 'STUDY CLAUSE)) (CDR EXP)))
(DEFUN STUDY-DECLARE (EXP)
;;; Picks up "fixnum, flonum, notype" all the time, looks for declaration
;;; info. when operating "One-pass".
(mapc '(lambda (form)
(prog (type body)
(setq type (car form)
body (cdr form))
(cond ((memq type '(fixnum flonum notype))
(go data-type))
((memq type '(*expr *fexpr *lexpr))
(go fn-type))
(t (return t)))
data-type
;;; (declare (flonum var1 var2 ... (<fn name> arg-type1 ...) ...))
;;; Variables get the property: DCL-TYPE whose value is the type.
;;; Functions get two properties: DCL-TYPE, and ARG-TYPES, where the
;;; value of "arg-types" is the given list.
(mapc '(lambda (item)
(cond ((atom item) ;;; a variable
(putprop item (list type) 'dcl-type))
(t ;;; a function
((lambda (fn arg-types)
(putprop fn (list type) 'dcl-type)
(putprop fn (list arg-types) 'arg-types))
(car item)
(cdr item)))))
body)
(return t)
fn-type
; first strip off the "*" from the declared type
(setq type (cdr (assq type '((*expr . expr)
(*fexpr . fexpr)
(*lexpr . lexpr)))))
(mapc '(lambda (item)
(addl 'userfns item)
(addl 'file-dcls item)
(putprop item type 'declared-type)
(putprop item (location) 'dcl-location))
body)
(return t)))
(cdr exp)))
(DEFUN STUDY-DO (EXP)
; old form = (DO var init repeat ...)
; new form = (DO ((var1 ...)) (;end test) ...)
; test = (atom (cadr exp))
(PROG (VAR-EXPS)
OLDFORM
(cond ((atom (cadr exp))
(ADDBOUND (LIST-IFY (CADR EXP))) ;loop variable
(study (caddr exp)) ;repeat expression
(study (cadddr exp)) ;end test
((LAMBDA (BOUNDVARS)
(study-prog-body (cddddr exp)))
(CONS (CADR EXP) BOUNDVARS))
(RETURN T)))
NEW-FORM
((LAMBDA (BOUNDVARS)
(MAPC 'STUDY VAR-EXPS)
(AND (CADDR EXP) (MAPC 'STUDY (CADDR EXP)))
(study-prog-body (cdddr exp)))
(AND
(CADR EXP)
(APPEND
BOUNDVARS
(ADDBOUND
(MAPCAR
'(LAMBDA (TRIPLE?)
(PROG (VAR INIT-VAL REP-VAL)
(SETQ VAR (CAR TRIPLE?))
(AND (CDR TRIPLE?)
(SETQ INIT-VAL (CADR TRIPLE?))
(CDDR TRIPLE?)
(SETQ REP-VAL (CADDR TRIPLE?)))
(AND INIT-VAL (STUDY INIT-VAL))
(AND REP-VAL
(SETQ VAR-EXPS (CONS REP-VAL VAR-EXPS)))
(RETURN VAR)))
(CADR EXP))))))))
(DEFUN STUDY-ERR (EXP) (AND (CDR EXP) (STUDY (CADR EXP))))
(DEFUN STUDY-ERRSET (EXP) (STUDY (CADR EXP)))
(DEFUN STUDY-EVAL (EXP) (STUDY (CADR EXP)))
(DEFUN STUDY-EQ (EXP) (STUDY (CADR EXP)) (STUDY (CADDR EXP)))
(DEFUN STUDY-FUNCALL (EXP) (STUDY (CADR EXP)))
(DEFUN STUDY-GO (EXP)
(COND ((ATOM (CADR EXP))
(AND (BOUNDP 'UNSEEN-GOTAGS)
;;"unseen-gotags" will be bound if we are within a prog
(OR (MEMQ (CADR EXP) TAGS)
(SETQ UNSEEN-GOTAGS (CONS (CADR EXP) UNSEEN-GOTAGS)))))
(T (STUDY (CADR EXP)))))
(DEFUN STUDY-LAMBDA (EXP)
(PROG (ARGS BODY)
(SETQ ARGS (CADR EXP) BODY (CDDR EXP))
(AND (NULL BODY) (RETURN T))
(ADDBOUND ARGS)
(MAPC '(LAMBDA (V)
(OR (ATOM V) (WARN 'FN-WITH-NON-ATOMIC-ARG))
(ADDL 'USERVARS V))
ARGS)
((LAMBDA (BOUNDVARS) (MAPC 'STUDY BODY))
(APPEND (LIST-IFY ARGS) BOUNDVARS))))
(defun study-lap (exp)
; records function name, location in the file, and argument type
; exp = (LAP foo type)
;
(prog (defunction type stmt)
(setq defunction (cadr exp)
type (caddr exp))
(addl 'userfns defunction)
(addl 'defined-fns defunction)
(addl 'file-defuns defunction)
(putprop defunction
(cons (location) (get defunction 'defined-in))
'defined-in)
(putprop defunction
(cons type (get defunction 'type))
'type)
; now schlep away all the exp's till a NIL is read - lap code is ignored
slurp
(setq stmt (read))
(cond ((null stmt) ;read a nil
(return t))
(t (go slurp))) ))
(DEFUN STUDY-MACRO (EXP)
(PROG (MACRO-FN)
(ADDP DEFUNCTION *car 'CALLS-MACROS)
(ADDP *car DEFUNCTION 'CALLED-BY)
(OR EXPAND-MACROS (RETURN T))
(COND ((SETQ MACRO-FN (GET (CAR EXP) 'MACRO)))
(T (WARN 'CALLS-MACRO-BEFORE-ITS-DEFINED) (RETURN T)))
;n.b. if the body of the macro was an atom (implicit definition)
;we would have to have kept the expr code for it lying around,
;(which we haven't) - so it isn't expanded.
(cond ((atom macro-fn)(return t))
((ERRSET (setq exp (APPLY MACRO-FN (LIST EXP)))))
(T (WARN 'MACRO-LOST) (RETURN T)))
(STUDY EXP)))
(DEFUN STUDY-MAP (EXP)
(PROG (MAPPING)
(COND ((ATOM (CADR EXP)) (STUDY-VAR (CADR EXP)))
((ATOM (CADADR EXP))
;;; as in "(mapc 'set a b)"
(MARK (CADADR EXP)))
(T (SETQ MAPPING T) (STUDY (CADR EXP))))
(MAPC 'STUDY (CDDR EXP))))
(DEFUN STUDY-NOT-ATOM-FN (EXP)
(COND ((EQ (CAAR EXP) 'LAMBDA)
(STUDY-LAMBDA (CAR EXP))
(MAPC 'STUDY (CDR EXP)))
(T (MAPC 'STUDY (CDR EXP)))))
(DEFUN STUDY-QUOTE (EXP)
(COND ((AND (NOT (ATOM (CADR EXP))) (EQ (CAADR EXP) 'LAMBDA))
(STUDY-LAMBDA (CADR EXP))))
(AND (EQ (CAR EXP) 'FUNCTION) (ATOM (CDR EXP)) (MARK (CDR EXP))))
(DEFUN STUDY-PROG (EXP)
(ADDBOUND (CADR EXP))
(MAPC '(LAMBDA (V)
(OR (ATOM V) (WARN 'FN-WITH-NON-ATOMIC-ARG))
(ADDL 'USERVARS V))
(CADR EXP))
((LAMBDA (BOUNDVARS)
(study-prog-body (cddr exp)))
(APPEND (CADR EXP) BOUNDVARS)))
(defun study-prog-body (body)
; pulled out as a subroutine because DO's also allow tags and goto's
; in their bodies.
(prog (tags unseen-gotags)
(MAPC '(LAMBDA (EXP)
(COND ((ATOM EXP) ; i.e. a tag
(COND ((MEMQ EXP TAGS) ;if we've seen it before
(WARN 'DUPLICATED-GO-TAG))
(T (cond ((MEMQ EXP UNSEEN-GOTAGS)
; this will happen if STUDY-GO saw this tag
; earlier in the prog, before it appeared
; lexically.
; N.B. !!! this scheme of binding on the tag collection
; variables will miss legal tags in an enveloping progs
; and will therefore warn about things which are ok in the
; interpreter.
(SETQ UNSEEN-GOTAGS
(DELETE EXP UNSEEN-GOTAGS))))
(SETQ TAGS (CONS EXP TAGS)))))
(T (STUDY EXP))))
(CDDR EXP))
(AND UNSEEN-GOTAGS (WARN 'MISSING-GO-TAG))))
(DEFUN STUDY-SETQ (EXP)
(MAPC2 (FUNCTION (LAMBDA (X Y)
(OR (ATOM X) (WARN 'SETQ-NON-ATOMIC-EXP))
(ADDL 'USERVARS X)
(COND ((MEMQ X BOUNDVARS)
(ADDP X DEFUNCTION 'SETQ-BOUND))
((EQ defunction '*TOPLEVEL*)
(ADDL 'GLOBAL-SET X)
(ADDL 'FILE-GLOBALSET X)
(ADDP X
'*TOPLEVEL*
'BOUND-IN)
(ADDP X
(LIST FILE
'"pg. "
PAGE)
'SET-ON)
(ADDL 'TOPLEVEL-VARS X))
((ADDP X DEFUNCTION 'SETQ-FREE)
(ADDP DEFUNCTION X 'FREEVARS-SETQ)
(ADDL 'FILE-SPECVARS X)
(ADDL 'FREEVARS X)))
(STUDY Y)))
(CDR EXP)))
(defun study-setsyntax (exp)
;if the user smashes the readtable as their code is being read in, the
;INDEXR must also smash its (protected copy of the) readtable so as to
;catch macro characters and the like.
; If a SETSYNTAX expression involves unevaluatable code (a variable, a
;function name - almost anything except numbers or immediate expressions)
;then it cannot be executed.
;
(cond ((eq defunction '*toplevel*)
;else the call wouldn't have been executed by the real-eval-print
;loop, and INDEXR shouldn't either.
(cond ((errset (eval exp)))
;let LISP find out if non-immediate exp's were used
(t (warn 'unsetsyntax))))))
(DEFUN STUDY-SSTATUS (EXP)
;;; to many ideosyncratic things to for general study
;;; so just a place-holder to keep things from
;;; mucking up.
T)
(DEFUN STUDY-STATUS (EXP) T)
(DEFUN STUDY-THROW (EXP) (STUDY (CADR EXP)))
(DEFUN STUDY-VAR (VAR)
(COND ((MEMQ VAR BOUNDVARS))
((NUMBERP VAR))
((MEMQ VAR '(NIL T))
;;; system variables are ignored
)
(T (cond ((eq defunction '*toplevel*)
(addl 'file-globalset var)
(addl 'global-set var))
(t (ADDP DEFUNCTION VAR 'FREEVARS)
(ADDP VAR DEFUNCTION 'FREE-IN)))
(ADDL 'FILE-SPECVARS VAR)
(ADDL 'FREEVARS VAR)
(ADDL 'USERVARS VAR))))
;;;*********************************************************
;;;
;;; Indexing routines for MACLISP functions not normally indexed
;;;
;;;
;;; Additional indexing usually will require elements precisely
;;; analogous to those below, so for tutorial purposes I will
;;; always have them in a cannonical order.
;;;
;;; A call to deflist, associating functions anticipated as
;;; being in files, with the indexing functions
;;; written to process them.
;;;
;;; Initializations of any new data structures that are called for
;;;
;;; The analyzing function
;;;
;;; Any special output functions that are complimentary to the analysis
;;;#################################################################
;;; Recording the occurence of explicitly mentioned property
;;; list tags
;;;#################################################################
(study-one-pass!pass2
PUTPROP STUDY-PUTPROP
ADDP STUDY-PUTPROP
GET STUDY-GET)
(SETQ USER-PROPS NIL
;; the list that will hold all the properties that are found; analogous to
;;USERVARS
)
;;; New data tags:
;;; puts-prop - given to functions, indecating they put the
;;; indecated tags on some atom(s) somewhere in
;;; their execution
;;; put-by - given to properties; passive form of above
;;; gets-prop - for functions, analogous to puts-prop
;;; got-by - complement just like put-by
;;;
(DEFUN STUDY-PUTPROP (EXP)
;;exp looks like "(putprop <atom> <value> '<tag>)" note that only quoted tags
;;can be indexed
(COND ((AND (NOT (ATOM (CADDDR EXP))) (EQ (CAR (CADDDR EXP)) 'QUOTE))
((LAMBDA (PROP) (ADDP defunction PROP 'PUTS-PROP)
(ADDL 'USER-PROPS PROP)
(ADDP PROP defunction 'PUT-BY))
(CADR (CADDDR EXP))))))
(DEFUN STUDY-GET (EXP)
;; exp = "(get <atom> '<tag>)"
(COND ((AND (NOT (ATOM (CADDR EXP))) (EQ (CAR (CADDR EXP)) 'QUOTE))
((LAMBDA (PROPERTY) (ADDP defunction PROPERTY 'GETS-PROP)
(ADDP PROPERTY defunction 'GOT-BY)
(ADDL 'USER-PROPS PROPERTY))
(CADR (CADDR EXP))))))
(DEFUN review-tags NIL
(header '"Properties used explicitly")
(SETQ USER-PROPS (ALPHABETIZE USER-PROPS))
(DESCRIBE-M USER-PROPS 'PROPERTY-FACTS))
(facts PROPERTY-FACTS '((PUT-BY ("puton by functions:"))
(GOT-BY ("retrieved by functions:"))))
(facts USERFN-FACTS (APPEND USERFN-FACTS
'((PUTS-PROP ("puts on the properties"))
(GETS-PROPERTY ("/"gets/" the properties")))))
;;*PAGE
;;;%% SPEC
;;;********************************************************************************
;;;
;;; Routines for generating Compilation declarations for indexed files
;;;
;;;********************************************************************************
(DECLARE (SPECIAL EXPR FEXPR LEXPR MACRO))
(DEFUN MAKE-DCLS (FILELIST)
(PROG (↑R ↑W SPECVARS)
(SETQ FILELIST (MAPCAR '(LAMBDA (FILESPEC)
(COND ((ATOM FILESPEC) FILESPEC)
(T (CAR FILESPEC))))
FILELIST))
(OR (AND U-WRITE (ERT COMPLR-IFY: DO A UWRITE))
(APPLY 'UWRITE (LIST 'DSK USER-NAME)))
(IOC R)
(PRINC '/;DECLARATIONS/ MADE/ BY/ INDEXR/ )
(PRINC VERSION#)
(TERPRI)
(PRINC '/;ON/ )
(PRINC (TODAYS-DATE))
(NTERPRI 3.)
(COND ((= (LENGTH FILELIST) 1.)
(SETQ SPECVARS (APPEND (GET (CAR FILELIST)
'VARS-SET-AT-TOPLEVEL)
(GET (CAR FILELIST)
'USED-VARS-SPECIALLY)
(GET (CAR FILELIST)
'VARS-IN-MAP-LAMBDAS)))))
(MAPC
'(LAMBDA (FILE)
(PROG (DCL EXPR FEXPR LEXPR MACRO EXTRA-FNS)
(PRINC '/;DECLARATIONS/ FOR/ )
(PRINC (GET FILE 'FILE-NAME))
(TERPRI)
;;; find function types
(SETQ EXTRA-FNS
(CHOOSE '(LAMBDA (F) (NOT (STATUS SYSTEM F)))
(GET FILE 'CALLED-EXTERIOR-FNS)))
(MAPC '(LAMBDA (FN)
(COND ((NULL (GET FN 'TYPE))
(ERT FUNCTION WITHOUT TYPE))
((EQ (CAR (GET FN 'TYPE))
'*UNDEFINED*)
(TERPRI)
(PRINC '/;THE/ FUNCTION/ )
(PRINC FN)
(PRINC '/ WAS/ UNDEFINED))
(T (ADDL (CAR (GET FN 'TYPE))
FN))))
(APPEND (EVAL FILE) EXTRA-FNS))
(SETQ DCL
(LIST-NO-NILS 'DECLARE
(CONS 'SPECIAL SPECVARS)
(CONS '*EXPR (NREVERSE EXPR))
(CONS '*FEXPR (NREVERSE FEXPR))
(CONS '*LEXPR (NREVERSE LEXPR))
(LIST 'GENPREFIX FILE)))
(SPRINTER DCL)
(NTERPRI 3.)
(RETURN DCL)))
FILELIST)
(OR (AND U-FILE ((LAMBDA (↑R ↑W) (ERT DO A UFILE)) NIL NIL))
(APPLY 'UFILE (LIST (CAR FILELIST) 'DCLS)))))
(DECLARE (UNSPECIAL EXPR FEXPR LEXPR MACRO))
(DEFUN MARKUP (FILES)
;;; This checks to see that all variables ever used specially are
;;; declared as such in the file where they are bound. Apparently
;;; this requires tracing the flow of control upwards from the
;;; point in the file where the variable is used specially to the
;;; function where it is bound and mark that function specially if
;;; it is not in the same file as the function where the variable
;;; was special.
;;;
;;; Some LISP functions such as FUNCALL cause unfortunate opacities
;;; in the upward trace; hence the notion of "orphan" varialbes
;;; which must be declared special in every file inorder not to
;;; miss anything.
;;;
(SETQ ORPHANS NIL)
(MAPC
'(LAMBDA (FILE)
(PROG (BOUND-INSIDE BOUND-OUTSIDE ORPHANED)
(MAPC
'(LAMBDA (SOURSE-FN)
(MAPC
'(LAMBDA (FREEVAR)
(PROG (BINDING-FN)
;;trace-back is for side-effects
(TRACEBACK FREEVAR
(DELETE SOURSE-FN
(GET SOURSE-FN
'CALLED-BY))
(LIST SOURSE-FN)
1.)
(COND
((SETQ BINDING-FN (GET FREEVAR
'BINDING-FOUND))
(COND ((EQ (CAR (GET BINDING-FN
'DEFINED-IN))
FILE)
(ADDL 'BOUND-INSIDE FREEVAR))
(T (ADDL 'BOUND-OUTSIDE FREEVAR)
(ADDP FREEVAR
BINDING-FN
(MAKE-ATOM FILE
'OUTSIDE-SPECIAL)))))
(T (COND ((MEMQ FREEVAR
(GET FILE
'VARS-SET-AT-TOPLEVEL))
(ADDL 'BOUND-INSIDE FREEVAR))
((MEMQ FREEVAR GLOBAL-SET)
(ADDL 'BOUND-OUTSIDE FREEVAR)
(ADDP FREEVAR
(GET FREEVAR 'SETON)
(MAKE-ATOM FILE
'OUTSIDE-SPECIAL)))
(T (ADDL 'ORPHANED FREEVAR)
(ADDL 'ORPHANS FREEVAR)))))))
(GET SOURSE-FN 'FREEVARS)))
(GET FILE 'FILEFNS))
(PUTPROP FILE BOUND-INSIDE 'BOUND-INSIDE)
(PUTPROP FILE BOUND-OUTSIDE 'BOUND-OUTSIDE)
(PUTPROP FILE ORPHANED 'ORPHANED)))
FILES))
(DEFUN TRACEBACK (VAR FNS-TO-CHECK FNS-PASSED-THROUGH PRINT-COL)
(PROG (FILE)
(MAPC
'(LAMBDA (FN)
(TAB PRINT-COL)
(PRINC FN)
(COND ((MEMQ FN FNS-PASSED-THROUGH))
((MEMQ VAR (GET FN 'BOUNDVARS))
(PUTPROP VAR FN 'BINDING-FOUND)
(ADDP FN VAR 'LOWER-SPECIAL))
((OR (NULL (GET FN 'CALLED-BY))
(FULLY-INCLUDES FNS-PASSED-THROUGH
(GET FN 'CALLED-BY)))
(SETQ FILE (CAAR (GET SOURSE-FN
'DEFINED-IN))))
(T (TRACEBACK VAR
(GET FN 'CALLED-BY)
(CONS FN FNS-PASSED-THROUGH)
(1+ PRINT-COL)))))
FNS-TO-CHECK)))
;;*page
;;;%% PRIN
;;;***************************************************************
;;;
;;; output
;;;
;;;***************************************************************
;;;
;;; Relevant global variables (bound in MAKEFILE)
;;;
;;; page - used by the function "page" which outputs ↑l's and prints
;;; the page numbers - initialize it to one
;;; base - is usually more convenient as 10.
;;;
;;;
;;; LINEL - is currently allowed to take the lisp default value according
;;; to the kind of screen being used. (i.e. 95 on a TV)
;;;
(SETQ DEFAULT-OUTFILE '(/.INDEX >))
; default name of the file of statistics produced by standard-output
(setq PAGESIZE 52
linel 110)
; default number of lines in an output page. Optimal for output on the
; for the ML lineprinter.
; The values can be changed by SETQ'ing these variables in an INIT file, or
; by feeding a symbol to the options list of a call to INDEX.
; 22FG - The user will be putting the file out via the XGP and will
; be using that font.
; linel = 110 pagesize = 72
;
; 25FG linel = 95 (???) pagesize = 60
(setq PRINTING-BASE 10.)
(DEFUN MAKEFILE largs
;;; as a function of no arguments, it uses the value of "output-fns"
;;; for the printing instruction list. One argument is taken as the
;;; name of an alternative list.
;;;
(PROG (↑W ↑R ↑D PAGE OUT-DIR FILE-NAMEs printing-fns)
(cond ((= (arg nil) 0)
(setq printing-fns output-fns))
(t (setq printing-fns (arg 1))))
(SETQ BASE PRINTING-BASE page 1)
(COND (U-WRITE (SETQ OUT-DIR
(QUERY '"directory for output = "
'"give a directory name followed by a space")))
(T (SETQ OUT-DIR USER-name)))
(APPLY 'UWRITE (LIST 'DSK OUT-DIR))
(SETQ ↑R T)
(OR PRINT-TTY (SETQ ↑W T))
;
(cond (anti-lossage
(errset (MAPC '(LAMBDA (FN) (eval FN)) printing-fns)))
(t (mapc '(lambda (fn)(eval fn)) printing-fns)))
;
(COND (U-FILE (SETQ FILE-NAMES
(QUERY '"file names = "
'"give a list of (fn1 fn2)")))
(T (SETQ FILE-NAMES DEFAULT-OUTFILE)))
(APPLY 'UFILE FILE-NAMES)
(really-printc '"printing done")
(return '*)))
(setq output-fns ; this is the default set !!!
'((files-indexed)
(functions-defined)
(undefined-functions)
(unused-functions)
(variables-used-free)
(review-tags)
(review-userfns)
(review-uservars)))
(defun files-indexed ()
; intended as a header to the whole output
(line-of '#)
(turpri)
(printc '" These files were indexed on ")
(princ (todays-date))
(princ '" by INDEXR ")
(princ version#)
(mapc '(lambda (filename)
(tab 15.)
(princ filename))
(reverse realfiles))
(turpri)
(turpri)
(line-of '#))
(DEFUN FUNCTIONS-DEFINED NIL
(nturpri 2)
(print-data '"The functions defined were:"
(setq defined-fns (alphabetize defined-fns))))
(DEFUN UNDEFINED-FUNCTIONS NIL
(nturpri 2)
(print-data '"functions called but not defined here:"
(setq undefns (alphabetize undefns))))
(DEFUN UNUSED-FUNCTIONS NIL
(nturpri 2)
(print-data '"functions defined, but never called:"
(alphabetize
(choose (function (lambda (fn)
(not (get fn 'called-by))))
userfns))))
(DEFUN VARIABLES-USED-FREE NIL
(nturpri 2)
(print-data '"variables ever accessed free:"
(setq freevars (alphabetize freevars))))
(DEFUN REVIEW-USERFNS NIL
(SETQ USERFNS (ALPHABETIZE USERFNS))
(HEADER '"Review of the functions indexed")
(DESCRIBE-M USERFNS 'USERFN-FACTS))
(DEFUN REVIEW-USERVARS NIL
(SETQ USERVARS (ALPHABETIZE USERVARS))
(HEADER '"Review of the variables indexed")
(DESCRIBE-M USERVARS 'USERVAR-FACTS))
(DEFUN REVIEW-LISPFNS NIL
(SETQ LISPFNS (ALPHABETIZE LISPFNS))
(HEADER '"Review of (selected) LISP functions used")
(DESCRIBE-M LISPFNS 'LISPFN-FACTS))
;;*page
;################################################################
; multi-file statistics
;################################################################
(defun fns-called-outside-file ()
; goes through all the indexed files. For each, it checks the "undefined"
; fns, and prints out what (other) file each such fn was defined in.
;
(header '"Function calls outside of each file")
(mapc '(lambda (file)
(turpri)
(princ '" ")
(princ file)
(prog (undefns)
(setq undefns (get file 'calls-to-exterior))
(cond ((null undefns) (princ '" none") (return t)))
((lambda (indent)
(setq undefns (alphabetize undefns))
(mapc '(lambda (fn)
(prog (home-file)
(setq home-file (car (get fn 'defined-in)))
(or home-file (return t))
(tab indent)
(princ fn)
(princ '" ")
(princ home-file)))
undefns))
(1+ (current-X-pos))) ))
filenames))
(defun free-vars-per-file ()
;goes through all the files, listing its SPECVARS
(mapc '(lambda (file)
((lambda (freevars)
(cond (freevars
(turpri)
(print-data
(maknam (append (exploden '"Free variables in ")
(exploden file)))
freevars))))
(get file 'specvars)))
filenames))
(defun fexprs-called-per-file ()
;good for complr declarations
(mapc '(lambda (file)
((lambda (fexprs)
(cond (fexprs
(turpri)
(print-data
(maknam (append (exploden '"Fexprs mentioned in ")
(exploden file)))
fexprs))))
(choose (function (lambda (fn)
(eq 'fexpr (car (get fn 'type)))))
(get file 'fns-called))))
filenames))
;################################################################
; Special printing functions for INDEXR
;################################################################
(DEFUN DESCRIBE-M (LIST FACT-LIST)
;"describe-moby" - the workhorse of the printing system.
; - works in conjunction with the "facts" lists compiled for each type of
; object that the INDEXR pays attention to. LIST is the name of a variable
; whose value is a list of instances of that type, e.g. USERFNS, USERVARS, etc.
;
(MAPC '(LAMBDA (X) (DESCRIBE X FACT-LIST)) LIST))
(DEFUN DESCRIBE (ITEM FACTLIST)
; The per-item subroutine that does the accounting of lines and bumps
; the page on cue. The factlist is stepped through by the routine
; PRINTFACT, which does the actual printing - at a given margin (5 spaces).
(TURPRI)
(OR (GREATERP (- PAGESIZE LINECOUNT) 3.) (PAGE))
(PUTPROP ITEM PAGE 'PAGE) ;useable in an index of the output
(PRINT ITEM)
;Each "factlist" is an atom whose value is a list of schema.
; (( tag1 ("...text string..."))
; ( tag2 ...)
; ...)
(MAPC '(LAMBDA (schema)
((lambda (tag text)
(printfact text (get item tag) 5.))
(car schema)
(cadr schema)))
(EVAL FACTLIST)))
(DEFUN PRINTFACT (TEXT ITEMS MARGIN)
;'knows the TEXT to be an atom with a text string for a pname.
; Calls MAPRINT to print the list of items at a further indented
; margin
;
(cond (items ;null lists are ignored
(turpri)
(write-spaces margin)
(princ (car text)) ;extra "car" matches archaic parens in FACT's
(MAPRINT ITEMS (+ MARGIN 27.)) )) )
(DEFUN MAPRINT (TEXT MARGIN)
;TEXT is a list of atoms, which are printed in a block at the specified margin.
(PROG nil
(cond ((null text) (return t))) ;don't even do the tab
(TAB MARGIN)
(setq terpri t) ;suppress automatic insertion of cf-lf's
loop
(COND ((null text) (return t))
((NOT (ATOM (CAR TEXT)))
;embedded list - open it up and splice it into the pending text
(setq text
(append '(|(|) (car text) '(|)|) (cdr text))) )
((> (flatc (car text)) (- (line-length) (left-mar)))
;pname won't fit on the space left on the line
(cond ((> (flatc (car text)) (- (line-length) margin))
;pname won't ever fit on this margin - just print it anyway
(princ (car text))
(setq text (cdr text))
(cond (text (turpri) (tab margin))) )
(t ;start pname on a new line
(turpri) (tab margin)
(princ (car text))
(setq text (cdr text))
(cond (text (princ '| |))) )))
(t ;normal case
(princ (car text))
(setq text (cdr text))
(cond (text (princ '| |))) ))
(go loop) ))
(DEFUN HEADER (MESSAGE)
(PAGE)
(LINE-OF '=)
(center-printc message)
(LINE-OF '=)
(TURPRI))
(DEFUN SECTION-HEADER (MESSAGE)
(LINE-OF '#)
(SAY-M MESSAGE (CENTER-STARTER MESSAGE))
(TURPRI)
(LINE-OF '#))
(DEFUN NTURPRI (#) (DO ((I # (1- I))) ((= I 0.) 'T) (TURPRI)))
(DEFUN TURPRI NIL
(TERPRI)
(SETQ LINECOUNT (1+ LINECOUNT))
(COND ((= LINECOUNT PAGESIZE) (PAGE))))
(DEFUN NEXTPAGE NIL (SETQ PAGE (1+ PAGE)))
(DEFUN PAGE NIL
(TYO 12.)
(PRINT 'PAGE)
(PRINC (NEXTPAGE))
(SETQ LINECOUNT 0.)
(TURPRI))
;;;************************************************************************
;;; various more general functions for variously printing various things
;;;************************************************************************
(DEFUN CENTER-printc (MESSAGE)
; takes a "'ed string as a message - assumes it is one line long (!!!)
; and gets it printed in the center of the next line.
(prog (indent l)
(setq indent (cond ((> (setq l (flatsize message)) linel) 0)
(t (// (- linel l) 2))))
(turpri)
(write-spaces indent)
(princ message)))
(defun col-print (list indentation)
; prints the items of the list in two columns. Alphabetically, down the
; first col then the next, by page.
(prog (lines-left items-this-page col1 col2 next-page lines-to-print)
per-page
(setq lines-left (- pagesize linecount)
items-this-page (* 2 lines-left))
(cond ((> (length list) items-this-page)
; it must spill over this page - breakup the list accordingly
((lambda (split)
(setq col1 list
col2 (car split)
next-page (cdr split)))
(split-by-three list lines-left lines-left)))
(t (setq col1 list
col2 (ncdr (// (length list) 2) list))))
(setq lines-to-print
(cond (next-page (1- lines-left)) ; "1-" because of TURPRI below
(t (// (length list) 2))))
; print out the two columns
(do ((c1 col1 (cdr c1))
(c2 col2 (cdr c2))
(i 0 (1+ i)))
((= i lines-to-print))
(turpri)
(write-spaces indentation)
(and c1 (prin1 (car c1)))
(tab (+ indentation 30))
(and c2 (prin1 (car c2))))
(cond (next-page ;more items to be printed
(setq list next-page
next-page nil)
(go per-page))
(t (return '*)))))
(DEFUN LINE-OF (CHAR)
(turpri)
(DO ((I (1- LINEL) (1- I))) ((= I 0.)) (PRINC CHAR)))
(defun print-data (message list)
;prints the one line "'ed message and then prints the list of atoms.
; either in a block if less than 10, or in a double column. Assumes
; that the list is already alphabetized.
(and (< (- pagesize linecount) 6) (page))
(turpri)
(princ message)
(cond ((null list) (princ '" none"))
; (< (length list) 10.)
(t (maprint list 20.))))
; (t (col-print list 20.))
; -recalcetrant double printing bug 5/21
(declare (fixnum column tab-length tabs))
(setq tab-length 8.)
(DEFUN TAB (COLUMN)
;moves the cursor directly over "column" i.e. the next princ will put its first character
;on the "X". left edge| <-- (1- "column") spaces -->|X
;by inserting a new line if the current position is beyond that point.
;
((lambda (present-pos)
(prog (difference)
(cond ((null present-pos)(setq present-pos 0)))
(cond ((= column present-pos))
((< column present-pos)
(turpri)
;insert tabs as much as possible
(do ((tabs (quotient column tab-length) (1- tabs)))
((= tabs 0))
(tyo 9.))
(do ((s (remainder column tab-length) (1- s)))
((= s 0))
(tyo 32.)) )
(t (setq difference (- column present-pos))
(do ((tabs (quotient difference tab-length) (1- tabs)))
((= tabs 0))
(tyo 9.))
(do ((s (remainder difference tab-length) (1- s)))
((= s 0))
(tyo 32.)) )) ))
;;; comes in two version, depending on whether the material
;;; will be printed on the screen when CURSORPOS would be available
(cond (↑w ;;; printing is not going to the terminal
(left-mar))
(t (cdr (cursorpos))))
))
(DEFUN WRITE-SPACES (N) (DO ((I N (1- I))) ((= I 0.)) (TYO 32.)))
β
ββββ